home *** CD-ROM | disk | FTP | other *** search
/ Die Speccy' 97 / Die Speccy' 97.iso / amiga_system / the_aminet / util / wb / membar.lha / membar / Membar.mod
Text File  |  1995-10-01  |  4KB  |  180 lines
  1. (***************************************************************************
  2.  
  3.     MODUL
  4.       Membar.mod
  5.  
  6.     DESCRIPTION
  7.       Displays actual memory usage in a small window.
  8.  
  9.     NOTES
  10.       Membar is the Oberon-2 version of the Membar tool by
  11.       Andreas Tetzl <A.Tetzl@saxonia.de>.
  12.  
  13.       Membar is simply Freeware. You may use it for free but not for
  14.       any military subject.
  15.       This software comes with absolutely no warranty. Every use at
  16.       your own risk. I am not responsible for any damage caused direkt
  17.       or indirekt by this program. It works fine for me, that is all.
  18.  
  19.       This version is compiled using Oberon-A.
  20.       OC version: 5.37
  21.  
  22.     BUGS
  23.       sure
  24.  
  25.     TODO
  26.       tell me
  27.  
  28.     EXAMPLES
  29.       Just run it and it will open its window.
  30.       End with doubleklick in the window.
  31.  
  32.     SEE ALSO
  33.       Have a look at the titlebar of your WB. ;)
  34.  
  35.     INDEX
  36.  
  37.     HISTORY
  38.       30-09-95 Roland (rj,-) Jesse  created
  39.  
  40. ***************************************************************************)
  41.  
  42. <* STANDARD- *>             (* necessary for assignable cleanup procedure *)
  43.  
  44. MODULE Membar;
  45.  
  46. IMPORT
  47.    MembarRev,
  48.    Errors, Kernel,
  49.    d := Dos,
  50.    e := Exec,
  51.    gfx := Graphics,
  52.    i := Intuition,
  53.    S := SYSTEM,
  54.    s := Sets,
  55.    u := Utility;
  56.  
  57. TYPE
  58.    String = ARRAY 256 OF CHAR;
  59.  
  60. CONST
  61.    (* color definitions *)
  62.    BACKCOL = 2;
  63.    FULLCOL = 3;
  64.    EMPTYCOL = 0;
  65.    BARWIDTH = 150;
  66.  
  67.  
  68. VAR
  69.    win : i.WindowPtr;
  70.    scr : i.ScreenPtr;
  71.    rp : gfx.RastPortPtr;
  72.  
  73.    (* storing the various memory values *)
  74.    mem, oldmem, total : LONGINT;
  75.  
  76.    (* kind of memory for e.AvailMem *)
  77.    mask : s.SET32;
  78.    mask2 : s.SET32;
  79.  
  80.    sec, mic : LONGINT;
  81.  
  82.    msg : i.IntuiMessagePtr;
  83.  
  84.    (* Doubleklick in the window ? *)
  85.    CheckBreak : BOOLEAN;
  86.  
  87. (* displays EasyRequester with argument string *)
  88. PROCEDURE Req  (text: String);
  89. VAR
  90.   es : i.EasyStruct;
  91.   pushed : LONGINT;
  92.  
  93. BEGIN
  94.   es.structSize := SIZE (i.EasyStruct);
  95.   es.flags := {};
  96.   es.title := S.ADR ("Membar Information");
  97.   es.textFormat := S.ADR (text);
  98.   es.gadgetFormat := S.ADR ("OK");
  99.   pushed := i.EasyRequest ( NIL, S.ADR (es), NIL, NIL );
  100. END Req;
  101.  
  102.  
  103. (* open all needed stuff *)
  104. PROCEDURE Init;
  105. BEGIN
  106.  
  107.    scr := i.LockPubScreen ("Workbench");
  108.    IF scr = NIL THEN
  109.       Req ("CANT FIND WB");
  110.       HALT (d.error)
  111.    END;
  112.  
  113.    win := i.OpenWindowTagsA ( NIL,
  114.       i.waLeft, scr.width - BARWIDTH - 26,
  115.       i.waTop, 0,
  116.       i.waWidth, BARWIDTH,
  117.       i.waHeight, scr.barHeight,
  118.       i.waBorderless, TRUE,
  119.       i.waIDCMP, i.menuPick,
  120.       u.done );
  121.  
  122.    IF win = NIL THEN
  123.       Req ("Can't open window");
  124.       HALT (d.error)
  125.    END;
  126.  
  127.    rp := win.rPort;
  128.  
  129.    gfx.SetRast (rp, S.VAL (e.UBYTE, BACKCOL));
  130.    mask := {e.total};
  131.    total := e.AvailMem (mask);
  132.  
  133.    sec := 0; mic := 0; oldmem := 0
  134. END Init;
  135.  
  136.  
  137. (* Remove all the allocated stuff *)
  138. PROCEDURE* Cleanup (VAR rc : LONGINT);
  139. BEGIN
  140.  IF win # NIL THEN i.CloseWindow (win) END
  141. END Cleanup;
  142.  
  143.  
  144. BEGIN (* MemBar *)
  145.    Errors.Init;
  146.    Kernel.SetCleanup (Cleanup);
  147.  
  148.    Init;
  149.  
  150.    CheckBreak := FALSE;
  151.    REPEAT
  152.       mask := {e.chip}; mask2 := {e.fast};
  153.       mem := total - e.AvailMem (mask) - e.AvailMem (mask2);
  154.  
  155.       IF ABS (mem - oldmem) > 1024 THEN
  156.          gfx.SetAPen (rp, EMPTYCOL);
  157.          gfx.RectFill (rp, 1, 2, win.width-2, win.height-3);
  158.          gfx.SetAPen (rp, FULLCOL);
  159.          gfx.RectFill (rp, 1, 2, S.VAL (INTEGER, (win.width-2) * mem DIV total), win.height-3);
  160.       END;
  161.  
  162.       oldmem := mem;
  163.       d.Delay(50);
  164.  
  165.       msg := S.VAL (i.IntuiMessagePtr, e.GetMsg (win.userPort));
  166.       IF msg # NIL THEN
  167.          IF i.DoubleClick (sec, mic, msg.time.secs, msg.time.micro) THEN
  168.                e.ReplyMsg (msg);
  169.                HALT (d.ok)
  170.             END;
  171.          e.ReplyMsg (msg);
  172.          sec := msg.time.secs;
  173.          mic := msg.time.micro
  174.       END;
  175.  
  176.    UNTIL CheckBreak = TRUE;
  177.  
  178. END Membar.
  179.  
  180.